perm filename AEJ[PIC,LCS] blob sn#039044 filedate 1973-12-30 generic text, type T, neo UTF8
00100		SUBROUTINE EDGE(X,Y)
00200
00300	C	DECEMBER 12,  68
00400
00500
00600		DIMENSION T(0/1770)
00700
00800		REAL A0,A1,A2,A3,A4,A5,A6,A7,
00900		1 COH,B,
01000		2 AF,CL,C2L,CW,D,
01100		3 LEN,L,RO,SL,SW,
01200		4 S2L,RX,RY,HALF,RO2,
01300		5 HEL,RR,RORR,Q,LC,
01400		6 E,EC,ES,ECP,ESP,EX,SQ,SQP
01500
01600		INTEGER COUNT,X,Y
01700
01800		LOGICAL DEBUG
01900
02000		COMMON /EDGEC/ A0,A1,A2,A3,A4,A5,A6,A7,
02100		1 DEBUG,T,
02200		1 HALF,FILE,RR,COH,RX,RY,CL,SL,D,B,FOUND
02300
02400		CALL PROJEC(X,Y)
02500
02600		Q=SQRT(6.*A1**2+2.*(A2**2+A3**2+A4**2+A5**2)+
02700		1 3.*(A6**2+A7**2))
02800
02900		COUNT=-1
03000		L=1.
03100		CL=A2+A4
03200		SL=A3+A5
03300
03400	100	COUNT=COUNT+1
03500		LEN=SQRT(CL**2+SL**2)
03600		CL=CL/LEN
03700		SL=SL/LEN
03800		E=A2*CL+A3*SL
03900		IF(E.GT.0.) GOTO 200
03910	CC	IF(E.GT.0.) GOTO 150
04000		CL=-CL
04100		SL=-SL
04200		E=-E
04300	CC150	IF(.NOT.DEBUG) GOTO 200
04400	CC	CALL ASD(2,'CL',CL)
04500	CC	CALL ASD(2,'SL',SL)
04600	200	C2L=CL**2-SL**2
04700		S2L=2.*SL*CL
04800		EC=A4*CL+A5*SL
04900		EX=A6*C2L+A7*S2L
05000		ES=A1+EX
05100		SQ=SQRT(EC**2+ES**2)
05200		IF(L**2.LT.1.E-3.OR.COUNT.GT.1) GOTO 250
05300		ECP=-A4*SL+A5*CL
05400		ESP=2.*(-A6*S2L+A7*C2L)
05500		SQP=(EC*ECP+ES*ESP)/SQ
05600		L=-(-A2*SL+A3*CL+SQP)/(-E+(-SQP**2+
05700		1 ECP**2+ESP**2-EC**2-4.*ES*EX)/SQ)
05800		HEL=1.-(L**2)/2.
05900		LC=CL
06000		CL=CL*HEL-SL*L
06100		SL=SL*HEL+LC*L
06200		GOTO 100
06300
06400	250	CW=EC/SQ
06500		IF(CW.GE.0.) GOTO 260
06600		COH=0.
06700		D=0.
06800		B=0.
06900		RETURN
07000	260	SW=ES/SQ
07100	CC	IF(.NOT.DEBUG) GOTO 300
07200	CC	CALL ASD(4,'COUNT',COUNT)
07300	CC	CALL ASD(4,'CW',CW)
07400	CC	CALL ASD(4,'SW',SW)
07500	300	AF=E+SQ
07600		RO=SW/(1.4142136*(1.+CW))
07700		RO2=RO**2
07800		D=AF*1.30294/((1.-RO2)**2*(1.+2.*RO2))
07900		COH=AF/Q
08000		RORR=RO*RR
08100		RX=FLOAT(X)+0.5-HALF+CL*RORR
08200		RY=FLOAT(Y)+0.5-HALF+SL*RORR
08300		B=A0-D*(4.+RO*(3.+RO*(2.+RO)))*((1.-RO)**2)*0.125
08400		IF(COH.LT.-1.0.OR.1.0.LT.COH) PAUSE 'COH CHECK IN EDGE'
08500	CC400	IF(.NOT.DEBUG) RETURN
08600	CC
08700	CC	CALL ASD(3,'COH',COH)
08800	CC	CALL ASD(3,'D',D)
08900	CC	CALL ASD(3,'B',B)
09000	CC	CALL ASD(3,'RX',RX)
09100	CC	CALL ASD(3,'RY',RY)
09200	CC	CALL ACTES(RO,D,CL,SL)
09300		RETURN
09400		END